
exception Impossible

type const_t =
    Bool of bool
  | Int of int
  | String of string

type unop_t =
    Not
  | Neg
  | ToString
  | Write
  | Ref
  | Deref

type binop_t =
    Pair
  | Cons
  | Concat
  | Plus | Minus | Times | Divide
  | And | Or | LazyAnd | LazyOr
  | Eq | Ne | Le | Lt | Gt | Ge
  | Assign

type t =
    Const of const_t
  | Id of string
  | UnaryOp of unop_t * t
  | BinaryOp of binop_t * t * t
  | Seq of t * t
  | Fun of string list * t
  | Function of match_t list
  | Apply of t list
  | CurryUnary of unop_t
  | CurryBinary of binop_t
  | List of t list
  | Let of string * string list * t * t
  | LetRec of string * string list * t * t
  | If of t * t * t option
  | Match of t * match_t list
and match_t =
    MatchRule of pattern_t * t
and pattern_t =
    P_Const of const_t
  | P_Any
  | P_Id of string
  | P_Pair of pattern_t * pattern_t
  | P_Cons of pattern_t * pattern_t
  | P_List of pattern_t list
  | P_Unit

type global_t =
    G_Use of string
  | G_Let of string * string list * t
  | G_LetRec of string * string list * t
  | G_Expr of t

let next_fresh_id = ref 0

let get_fresh_id () =
  let res = "%" ^ (string_of_int !next_fresh_id) in
  incr next_fresh_id ;
  res

let expand_const =
  function
      Bool b -> Core.Bool b
    | Int n -> Core.Int n
    | String s -> Core.String s

let expand_unary_op =
  function
      Not -> Core.Not
    | ToString -> Core.ToString
    | Write -> Core.Write
    | Ref -> Core.Ref
    | Deref -> Core.Deref
    | _ -> raise Impossible

let expand_binary_op =
  function
      Pair -> Core.Pair
    | Cons -> Core.Cons
    | Concat -> Core.Concat
    | Plus -> Core.Plus
    | Minus -> Core.Minus
    | Times -> Core.Times
    | Divide -> Core.Divide
    | And -> Core.And
    | Or -> Core.Or
    | Eq -> Core.Eq
    | Ne -> Core.Ne
    | Le -> Core.Le
    | Lt -> Core.Lt
    | Assign -> Core.Assign
    | _ -> raise Impossible

let rec matchrule p e1 e2 e3 =
  match p with
    P_Const k -> Core.If(Core.BinaryOp(Core.Eq,e1,Core.Const (expand_const k)),e2,e3)
  | P_Id v -> Core.Let(v,e1,e2)
  | P_Any -> e2
  | P_Unit -> Core.If(Core.BinaryOp(Core.Eq,Core.Const Core.Unit,e1),e2,e3)
  | P_Pair(p1,p2) -> matchrule p1 (Core.UnaryOp(Core.First,e1)) (matchrule p2 (Core.UnaryOp(Core.Second,e1)) e2 e3) e3
  | P_Cons(p1,p2) -> Core.If(Core.BinaryOp(Core.Eq,Core.Const Core.Nil,e1),e3,
			     (matchrule p1 (Core.UnaryOp(Core.Head,e1)) (matchrule p2 (Core.UnaryOp(Core.Tail,e1)) e2 e3) e3))
  | P_List [] -> Core.If(Core.BinaryOp(Core.Eq,Core.Const Core.Nil,e1),e2,e3)
  | P_List pl -> matchrule (List.fold_left (fun acc p -> P_Cons(p,acc)) (P_List []) pl) e1 e2 e3

let matchfail = Core.UnaryOp(Core.Fail,Core.Const (Core.String "No match"))

let rec expand =
  function
      Const k -> Core.Const (expand_const k)
    | Id x -> Core.Id x
    | UnaryOp(Neg,t) -> expand (BinaryOp(Minus,Const (Int 0),t))
    | UnaryOp(op,t) -> Core.UnaryOp((expand_unary_op op), (expand t))
    | BinaryOp(Ge,t1,t2) -> expand (BinaryOp(Le,t2,t1))
    | BinaryOp(Gt,t1,t2) -> expand (BinaryOp(Lt,t2,t1))
    | BinaryOp(LazyAnd,t1,t2) -> expand (If(t1,t2,Some(Const(Bool false))))
    | BinaryOp(LazyOr,t1,t2) -> expand (If(t1,Const(Bool true),Some t2))
    | BinaryOp(op,t1,t2) -> Core.BinaryOp((expand_binary_op op), (expand t1), (expand t2))
    | Seq(t1,t2) -> Core.Let((get_fresh_id ()), (expand t1), (expand t2))
    | Fun(vl,t) -> List.fold_right (fun x acc -> Core.Fun(x, acc)) vl (expand t)
    | Function ml ->
	let x = get_fresh_id () in
	expand (Fun([x],Match(Id x,ml)))
    | Apply [] -> Core.Const Core.Unit
    | Apply (hd::tl) -> List.fold_left (fun acc t -> Core.Apply(acc, (expand t))) (expand hd) tl
    | CurryUnary op ->
	let x = get_fresh_id () in
	expand (Fun([x], UnaryOp(op,Id x)))
    | CurryBinary op ->
	let x = get_fresh_id ()
	and y = get_fresh_id () in
	expand (Fun([x;y], BinaryOp(op,Id x,Id y)))
    | List tl -> List.fold_right (fun t acc -> Core.BinaryOp(Core.Cons,(expand t),acc)) tl (Core.Const Core.Nil)
    | Let(x,al,t1,t2) -> Core.Let(x,(expand (Fun(al,t1))),(expand t2))
    | LetRec(x,al,t1,t2) -> Core.LetRec(x,(expand (Fun(al,t1))),(expand t2))
    | If(t1,t2,t3) ->
	let else_branch =
	  match t3 with
	    Some t3' -> expand t3'
	  | None -> Core.Const Core.Unit
	in Core.If((expand t1),(expand t2),else_branch)
    | Match(t,ml) -> List.fold_right (fun (MatchRule(p,t')) acc -> matchrule p (expand t) (expand t') acc) ml matchfail
	
